perm filename DRAWY[1,LMM] blob
sn#014503 filedate 1972-11-25 generic text, type T, neo UTF8
IMPLICIT INTEGER (A-Z)
COMMON LINE(20,4),NODE(20,4),STACK(1000)
COMMON LLN,NLN,S,L,FLN,RA,RI
DIMENSION ITIT(10,20),ITMP(20)
DIMENSION IPAT(2,11,5)
DIMENSION CONN(20,10)
DIMENSION BN(10,10)
REAL SQRT,FLOAT
DATA IEND/4HEND*/
DATA CONN /200*0/
DATA BN/100*0/
DATA IPAT/1,2,1,3,1,4,2,3,2,4,3,4,8*0,2,0,
1 1,2,2,3,3,4,4,5,5,6,6,3,2,5,1,4,6,1,0,0,3,1,
1 1,2,1,3,1,4,1,5,2,3,2,4,2,5,6*0,2,0,
2 44*0/
IFN=5
RMX=70
NSTR=0
C
C READ NEXT DATA SET FROM (IFN)
C
30 LLN=0
NLN=0
READ(IFN,1012,END=20) IAA
IF (IAA.GT.0) GO TO 17
NSTR=-IAA-1
READ(IFN,1012,END=20) IAA
17 CONTINUE
DO 13 I=1,20
13 CONN(I,1)=1
DO 4 IAB=1,IAA
READ(IFN,1009) ITMP(1),IA,(ITMP(I),I=2,20)
IF (ITMP(1).EQ.0) GO TO 5
NODE(ITMP(1),3)=IA
NLN=MAX0(NLN,ITMP(1))
DO 1 I=2,20
IF (ITMP(I).EQ.0) GO TO 4
IF (LLN.EQ.0) GO TO 7
DO 2 IA=1,LLN
IB=IA
IF (LINE(IA,1).EQ.ITMP(1).AND.LINE(IA,2).EQ.ITMP(I)) GO TO 3
IF (LINE(IA,2).EQ.ITMP(1).AND.LINE(IA,1).EQ.ITMP(I)) GO TO 1
2 CONTINUE
7 LLN=LLN+1
LINE(LLN,1)=ITMP(1)
LINE(LLN,2)=ITMP(I)
LINE(LLN,3)=1
LINE(LLN,4)=0
12 CONN(ITMP(1),1)=CONN(ITMP(1),1)+1
CONN(ITMP(1),CONN(ITMP(1),1))=ITMP(I)
CONN(ITMP(I),1)=CONN(ITMP(I),1)+1
CONN(ITMP(I),CONN(ITMP(I),1))=ITMP(1)
GO TO 1
3 LINE(IB,3)=LINE(IB,3)+1
1 CONTINUE
4 CONTINUE
5 FLN=1
8 IAA=1
9 READ(IFN,1001) (ITIT(IAA,I),I=1,18)
IAA=IAA+1
IF (ITIT(IAA-1,1).NE.IEND) GO TO 9
IAA=IAA-2
C
C PRINT INPUT INFO
C
10 IF (IAA.NE.0) WRITE(6,1003) ((ITIT(I,IA),IA=1,18),I=1,IAA)
NSTR=NSTR+1
IF (IAA.EQ.0) WRITE(6,1013) NSTR
FLN=FLN-1
WRITE(6,1004)
WRITE(6,1005) ((LINE(I,IA),IA=1,3),I=1,LLN)
GO TO 60
C
C END OF RUN
C
20 WRITE(6,1008)
DO 21 I=1,10
IB=I-1
DO 21 IA=1,10
IC=IA-1
21 IF (BN(I,IA).NE.0) WRITE(6,1014) IB,IC,BN(I,IA)
STOP
C
C INPUT/OUTPUT FORMATS
C
1001 FORMAT(18A4)
1002 FORMAT(20I2)
1003 FORMAT(1H1,10(18A4/))
1004 FORMAT(5X,10HLINE TABLE/19H FROM TO #BONDS)
1005 FORMAT(1H ,I3,3X,I3,4X,I3)
1006 FORMAT(///11H FACE TABLE//)
1007 FORMAT(1H ,10I3)
1008 FORMAT(13H1BOND SUMMARY//3X,2HTB,3X,2HDB,3X,6HNUMBER//)
1009 FORMAT(I3,1X,A1,3X,19I3)
1012 FORMAT(I5)
1013 FORMAT(1H1,10HSTRUCTURE ,I4///)
1014 FORMAT(1H ,2I5,I7)
C
C SORT LINES FOR USAGE COUNT
C
60 IA=LLN-1
DO 41 I=1,IA
IC=CONN(LINE(I,1),1)+CONN(LINE(I,2),1)
IAA=I+1
DO 41 IB=IAA,LLN
ID=CONN(LINE(IB,1),1)+CONN(LINE(IB,2),1)
IF (IC.GE.ID) GO TO 41
DO 42 IE=1,4
LA=LINE(I,IE)
LINE(I,IE)=LINE(IB,IE)
42 LINE(IB,IE)=LA
IC=ID
41 CONTINUE
C
C SORT LINES ACCORDING TO SIDE ARMS (DISCONNECTED)
C
DO 70 I=1,NLN
70 NODE(I,1)=0
DO 71 I=1,LLN
NODE(LINE(I,1),1)=NODE(LINE(I,1),1)+1
71 NODE(LINE(I,2),1)=NODE(LINE(I,2),1)+1
NXN=LLN
83 DO 72 I=1,NLN
IF(NODE(I,1).NE.1) GO TO 72
DO 73 IA=1,LLN
IB=IA
IF (LINE(IA,1).EQ.I.OR.LINE(IA,2).EQ.I) GO TO 74
73 CONTINUE
74 NXN=NXN-1
IF (IB.GT.NXN) GO TO 84
DO 75 IC=1,4
ID=LINE(IB,IC)
DO 76 IA=IB,NXN
76 LINE(IA,IC)=LINE(IA+1,IC)
75 LINE(NXN+1,IC)=ID
IB=NXN+1
84 NODE(LINE(IB,1),1)=NODE(LINE(IB,1),1)-1
NODE(LINE(IB,2),1)=NODE(LINE(IB,2),1)-1
GO TO 83
72 CONTINUE
C
C SORT LINE FOR NEWLY ALL DEFINED
C
DO 61 I=1,NLN
61 ITMP(I)=0
ITMP(LINE(1,1))=NLN+1
ITMP(LINE(1,2))=NLN
IG=NLN-1
I=2
62 IA=I
MX=0
ML=0
MN=0
68 L1=LINE(IA,1)
L2=LINE(IA,2)
IF(ITMP(L1).EQ.0.AND.ITMP(L2).EQ.0) GO TO 78
IF (ITMP(L1).EQ.0.OR.ITMP(L2).EQ.0) GO TO 63
64 IF (I.EQ.IA) GO TO 65
IB=IA-1
DO 66 IC=1,4
LA=LINE(IA,IC)
DO 67 ID=I,IB
67 LINE(IB+I-ID+1,IC)=LINE(IB+I-ID,IC)
66 LINE(I,IC)=LA
65 I=I+1
IF (I.GE.NXN) GO TO 79
GO TO 62
78 IA=IA+1
IF (IA.LE.NXN.AND.ML.NE.-1) GO TO 68
IA=ML
IF (ML.GT.0) ITMP(MN)=IG
ML=-1
IF (IA.GT.0) GO TO 64
IG=IG-1
IF (IA.EQ.0) GO TO 79
GO TO 62
63 IE=L1
IF (ITMP(L1) .NE. 0) IE=L2
IB=0
IBA=CONN(IE,1)
DO 77 IC=2,IBA
77 IB=IB+ITMP(CONN(IE,IC))
IF (IB.LE.MX) GO TO 78
ML=IA
MX=IB
MN=IE
GO TO 78
79 CONTINUE
C
C GET TOP SIDE INFO
C
DO 150 I=1,NLN
150 NODE(I,4)=0
NODE(LINE(1,1),4)=-1
NODE(LINE(1,2),4)=-1
NA=LINE(2,1)
IF (NA.NE.LINE(1,1).AND.NA.NE.LINE(1,2)) GO TO 151
NA=LINE(2,2)
151 NODE(NA,4)=1
DO 154 ID=1,1
DO 152 I=1,NLN
IA=NODE(I,4)
IF (IA.NE.0) GO TO 152
IAA=CONN(I,1)
DO 153 IB=2,IAA
IF (NODE(CONN(I,IB),4).GT.0) GO TO 155
153 CONTINUE
GO TO 152
155 NODE(I,4)=-10
152 CONTINUE
DO 156 I=1,NLN
156 IF (NODE(I,4).EQ.-10) NODE(I,4)=1
154 CONTINUE
C
C CHECK FOR COMPLICATED PATTERNS
C
RI=0
RA=1
C
C INITIALIZE--SET FIRST NODE
C
50 DO 100 I=1,NLN
NODE(I,1)=0
100 NODE(I,2)=0
STACK(1)=-1
NODE(LINE(1,1),1)=50
NODE(LINE(1,1),2)=50
LV=1
S=1
LN=1
STACK(1)=-1
C
C NEXT LINE
C
114 L1=LINE(LN,1)
L2=LINE(LN,2)
IF(NODE(L2,1).EQ.0) GO TO 112
IF (NODE(L1,1).NE.0) GO TO 113
LA=L2
L2=L1
L1=LA
112 STACK(S+1)=L2
STACK(S+2)=0
S=S+2
LV=LV+1
IA=CONN(L2,1)
XMN=0
XMX=100
YMN=0
YMX=100
RB=RA
IF (LN.GT.NXN) RB=1
IF (LV.NE.2) GO TO 116
XMN=51
YMN=50
116 DO 110 I=2,IA
IB=CONN(L2,I)
N1=NODE(IB,1)
IF (N1.EQ.0) GO TO 110
XMN=MAX0(XMN,N1-RB)
XMX=MIN0(XMX,N1+RB)
N2=NODE(IB,2)
YMN=MAX0(YMN,N2-RB)
YMX=MIN0(YMX,N2+RB)
110 CONTINUE
IF (XMN.GT.XMX.OR.YMN.GT.YMX) GO TO 120
NA=NODE(L2,4)
DO 111 IX=XMN,XMX
DO 111 IY=YMN,YMX
IF (NA.LE.0) GO TO 157
NB=IY*SX-IX*SY+50*(IX-IY+SY-SX)
IF (NB.LT.0) GO TO 111
157 CONTINUE
STACK(S+1)=IY
STACK(S+2)=IX
STACK(S+3)=L2
S=S+3
111 CONTINUE
GO TO 120
113 IF (RTLIN(LN).NE.0) GO TO 122
S=S+2
STACK(S-1)=0
STACK(S)=0
LV=LV+1
105 LN=LN+1
IF (LN.LE.LLN) GO TO 114
GO TO 300
C
C NEXT
C
122 LN=LN-1
120 N0=STACK(S)
IF (N0.LE.0) GO TO 130
NX=STACK(S-1)
NY=STACK(S-2)
NODE(N0,1)=0
IF (LV.NE.2) GO TO 158
SX=NX
SY=NY
158 CONTINUE
S=S-3
DO 121 I=1,NLN
IF (NX.EQ.NODE(I,1).AND.NY.EQ.NODE(I,2)) GO TO 120
121 CONTINUE
NODE(N0,1)=NX
NODE(N0,2)=NY
IF (RTLIN(LN).EQ.0) GO TO 105
NODE(N0,1)=0
GO TO 120
C
C POP
C
130 LV=LV-1
LN=LN-1
IF (N0.LT.0) GO TO 140
N1=STACK(S-1)
S=S-2
IF (N1.EQ.0) GO TO 131
NODE(N1,1)=0
NODE(N1,2)=0
131 GO TO 120
C
C FAIL
C
140 RA=RA+1
IF (RA.LE.3) GO TO 50
RI=1
GO TO 50
C
C OUTPUT ROUTINES
C
300 CONTINUE
302 NTB=1
NDB=1
DO 305 I=1,LLN
IF (LINE(I,3).EQ.2) NDB=NDB+1
305 IF (LINE(I,3).EQ.3) NTB=NTB+1
BN(NTB,NDB)=BN(NTB,NDB)+1
WRITE(6,1010)
1010 FORMAT(1H0,19H LOCATIONS OF NODES/5H NODE,5X,5HX-POS,5X,5HY-POS)
DO 301 I=1,NLN
301 WRITE(6,1011) I,NODE(I,1),NODE(I,2)
1011 FORMAT(1X,I3,5X,I5,5X,I5)
CALL DRPIC(0)
GO TO 30
C
C
C END OF MAIN PROGRAM
C
END
INTEGER FUNCTION RTLIN(L)
IMPLICIT INTEGER(A-Z)
COMMON LINE(20,4),NODE(20,4),STACK(1000)
COMMON LLN,NLN,S,LA,FLN,RA,RI
COMMON /COMMAT/ N(10,2),IA,LX1,LY1,LX2,LY2,ND1
DATA RINT,ROVL,RLEN,RTRI,RSQR,RHEX/48,2048,16,32,32,32/
REAL X,Y,SL,B,SLA,BA,FLOAT
RTLIN=0
L1=LINE(L,1)
L2=LINE(L,2)
LX1=NODE(L1,1)
LX2=NODE(L2,1)
LY1=NODE(L1,2)
LY2=NODE(L2,2)
C
C CHECK FOR INTERSECT AND OVERLAP
C
IF (LX2.NE.LX1) GO TO 421
SL=1024
B=LX1
GO TO 420
421 SL=FLOAT(LY2-LY1)/FLOAT(LX2-LX1)
B=LY2-SL*LX2
420 IA=L-1
IF (L.EQ.1) GO TO 404
DO 400 I=1,IA
LL1=LINE(I,1)
LL2=LINE(I,2)
LLX1=NODE(LL1,1)
LLX2=NODE(LL2,1)
LLY1=NODE(LL1,2)
LLY2=NODE(LL2,2)
IF (LLX2.NE.LLX1) GO TO 422
SLA=1024
BA=LLX2
GO TO 423
422 SLA=FLOAT(LLY2-LLY1)/FLOAT(LLX2-LLX1)
BA=LLY2-SLA*LLX2
423 IF (SL.EQ.SLA) GO TO 401
IF (LL1.EQ.L1.OR.LL1.EQ.L2.OR.LL2.EQ.L1.OR.LL2.EQ.L2) GO TO 400
IF (SL .EQ. 1024) GO TO 405
IF (SLA.EQ. 1024) GO TO 406
X=(BA-B)/(SL-SLA)
Y=SL*X+B
407 IF (X.GT.MAX0(LX1,LX2) .OR. X.LT.MIN0(LX1,LX2)) GO TO 400
IF (X.GT.MAX0(LLX1,LLX2).OR.X.LT.MIN0(LLX1,LLX2)) GO TO 400
IF (Y.GT.MAX0(LY1,LY2) .OR. Y.LT.MIN0(LY1,LY2)) GO TO 400
IF (Y.GT.MAX0(LLY1,LLY2).OR.Y.LT.MIN0(LLY1,LLY2)) GO TO 400
408 RTLIN=RTLIN+RINT*(1-RI)
GO TO 400
405 Y=SLA*B+BA
X=B
GO TO 407
406 Y=SL*BA+B
X=BA
GO TO 407
401 IF (B .NE. BA) GO TO 400
IF (SL .EQ. 1024) GO TO 402
IF (MAX0(LX1,LX2).LE.MIN0(LLX1,LLX2)) GO TO 400
IF (MIN0(LX1,LX2).GE.MAX0(LLX1,LLX2)) GO TO 400
GO TO 403
402 IF (MAX0(LY1,LY2).LE.MIN0(LLY1,LLY2)) GO TO 400
IF (MIN0(LY1,LY2).GE.MAX0(LLY1,LLY2)) GO TO 400
403 GO TO 411
400 CONTINUE
404 CONTINUE
508 RETURN
C
C FAILURE
C
411 RTLIN=RTLIN+ROVL
RETURN
END
SUBROUTINE SLOPE(I,S,B)
COMMON LINE(20,4),NODE(20,4),STACK(1000)
COMMON LLN,NLN,XSX,L,FLN,RA,RI
INTEGER STACK,FACE,XSX,FLN
Y1=FLOAT(NODE(LINE(I,1),2))
Y2=FLOAT(NODE(LINE(I,2),2))
X1=FLOAT(NODE(LINE(I,1),1))
X2=FLOAT(NODE(LINE(I,2),1))
IF (X2.EQ.X1) GO TO 801
S=(Y2-Y1)/(X2-X1)
B=Y2-S*X2
RETURN
801 S=1024
B=X2
RETURN
END
INTEGER FUNCTION INC(N,L)
I=(1+IFIX(SQRT(FLOAT(1+N))))/2
IA=N-4*I*(I-1)
IC=MOD(IA/4+I,2*I+1)-I
IB=MOD(IA,4)/2
ID=MOD(IA,2)*2-1
IX=I*ID*(IB-1)+IB*IC*ID
IY=I*ID*IB+(1-IB)*IC*ID
INC=IX
IF (L.EQ.2) INC=IY
RETURN
END
SUBROUTINE PMATCH(IPAT,IPA,IPB,IPC,IFLG,ITMP,NXN)
IMPLICIT INTEGER (A-Z)
COMMON LINE(20,4),NODE(20,4),STACK(1000)
COMMON LLN,NLN,S,L,FLN,RA,RI
DIMENSION IPAT(IPA,IPB,IPC),ITMP(20)
IFA=IFLG
IFLG=0
IF (1.EQ.1) RETURN
IF (NXN.EQ.0) RETURN
DO 86 J=IFA,IPC
IF (IPAT(1,NXN,J).EQ.0.OR.IPAT(1,NXN+1,J).NE.0) GO TO 86
DO 85 I=1,NLN
DO 87 IA=1,NLN
87 ITMP(IA)=0
ITMP(IPAT(1,1,J))=I
IA=0
89 IA=IA+1
IP1=IPAT(1,IA,J)
IP2=IPAT(2,IA,J)
IP3=0
IF (IP1.EQ.0) GO TO 93
IF (ITMP(IP2).NE.0) GO TO 94
IP3=1
ITMP(IP2)=1
91 DO 88 IB=1,NLN
IF (IB.NE.IP2.AND.ITMP(IP2).EQ.ITMP(IB)) GO TO 92
88 CONTINUE
94 ITMP(10+IA)=IP3
DO 90 IB=1,LLN
IF (LINE(IB,1).EQ.ITMP(IP1).AND.LINE(IB,2).EQ.ITMP(IP2)) GO TO 89
IF (LINE(IB,1).EQ.ITMP(IP2).AND.LINE(IB,2).EQ.ITMP(IP1)) GO TO 89
90 CONTINUE
IF (IP3.EQ.0) GO TO 95
92 ITMP(IP2)=ITMP(IP2)+1
IF (ITMP(IP2).LE.NLN) GO TO 91
95 IA=IA-1
IF (IA.EQ.0) GO TO 85
IP1=IPAT(1,IA,J)
IP2=IPAT(2,IA,J)
IP3=ITMP(IA+10)
GO TO 92
85 CONTINUE
GO TO 86
93 IFLG=J
RETURN
86 CONTINUE
RETURN
END
SUBROUTINE DRPIC(IFLG)
IMPLICIT INTEGER(A-Z)
COMMON LINE(20,4),NODE(20,4),STACK(1000)
COMMON LLN,NLN,S,LA,FLN,RA,RI
COMMON /PRIPLO/ AMODES(200),PFLD(50,50)
REAL AMODES
DATA SP/1H /
DO 612 I=1,30
DO 612 IA=1,30
612 PFLD(I,IA)=SP
CALL SCALE(IFLG)
DO 610 I=1,NLN
610 CALL DNODE(I,IFLG)
DO 611 I=1,LLN
611 CALL DLINE(I,IFLG)
CALL DNPIC(IFLG)
RETURN
END
SUBROUTINE SCALE (IFLG)
IMPLICIT INTEGER(A-Z)
COMMON LINE(20,4),NODE(20,4),STACK(1000)
COMMON LLN,NLN,S,LA,FLN,RA,RI
COMMON /PRIPLO/ AMODES(200),PFLD(50,50)
REAL AMODES
REAL FLOAT
XMX=0
YMX=0
XMN=10000
YMN=10000
DO 601 I=1,NLN
XMX=MAX0(XMX,NODE(I,1))
YMX=MAX0(YMX,NODE(I,2))
XMN=MIN0(XMN,NODE(I,1))
601 YMN=MIN0(YMN,NODE(I,2))
IF (IFLG.EQ.0) GO TO 602
C CALL MODESG(AMODES,'L MASINTER, 130, PGM=DRAWER',24)
C CALL SUBJEC(AMODES,FLOAT(XMN),FLOAT(YMN),FLOAT(XMX),FLOAT(YMX))
RETURN
602 AMODES(1)=FLOAT(XMN)
AMODES(2)=FLOAT(YMN)
AMODES(3)=FLOAT(4*XMX-4*XMN)+1.0
AMODES(4)=FLOAT(4*YMX-4*YMN)+1.0
RETURN
END
SUBROUTINE DNODE(I,IFLG)
IMPLICIT INTEGER(A-Z)
COMMON LINE(20,4),NODE(20,4),STACK(1000)
COMMON LLN,NLN,S,LA,FLN,RA,RI
COMMON /PRIPLO/ AMODES(200),PFLD(50,50)
REAL X,Y,AMODES
REAL FLOAT
IF (IFLG.EQ.0) GO TO 620
X=FLOAT(NODE(I,1))
Y=FLOAT(NODE(I,2))
C CALL VECSG(AMODES,X,Y,1,NODE(I,3))
RETURN
620 IX=(NODE(I,1)-AMODES(1))*4+1
IY=(NODE(I,2)-AMODES(2))*4+1
PFLD(IX,IY)=NODE(I,3)
RETURN
END
SUBROUTINE DLINE(I,IFLG)
IMPLICIT INTEGER(A-Z)
COMMON LINE(20,4),NODE(20,4),STACK(1000)
COMMON LLN,NLN,S,LA,FLN,RA,RI
COMMON /PRIPLO/ AMODES(200),PFLD(50,50)
REAL B,AMODES,X,Y
REAL FLOAT
DIMENSION CHR(5),X(2),Y(2)
DATA CHR/1H*,1H=,1H3,1H4,1H5/
IF (IFLG.EQ.0) GO TO 630
X(1)=FLOAT(NODE(LINE(I,1),1))
X(2)=FLOAT(NODE(LINE(I,2),1))
Y(1)=FLOAT(NODE(LINE(I,1),2))
Y(2)=FLOAT(NODE(LINE(I,2),2))
C CALL LINESG(AMODES,2,X,Y)
RETURN
630 IX1=(NODE(LINE(I,1),1)-AMODES(1))*4+1
IX2=(NODE(LINE(I,2),1)-AMODES(1))*4+1
IY1=(NODE(LINE(I,1),2)-AMODES(2))*4+1
IY2=(NODE(LINE(I,2),2)-AMODES(2))*4+1
DY=IY2-IY1
DX=IX2-IX1
IF (IABS(DY).GT.IABS(DX)) GO TO 635
IDX=ISIGN(1,DX)
IX=IX1+IDX
B=IY1-FLOAT(DY)/FLOAT(DX)*IX1
631 IY=FLOAT(DY)/FLOAT(DX)*IX+B+0.5
PFLD(IX,IY)=CHR(LINE(I,3))
IX=IX+IDX
IF(IX.NE.IX2) GO TO 631
RETURN
635 IDY=ISIGN(1,DY)
IY=IY1+IDY
B=IX1-FLOAT(DX)/FLOAT(DY)*IY1
632 IX=FLOAT(DX)/FLOAT(DY)*IY+B+0.5
PFLD(IX,IY)=CHR(LINE(I,3))
IY=IY+IDY
IF(IY.NE.IY2) GO TO 632
RETURN
END
SUBROUTINE DNPIC(IFLG)
IMPLICIT INTEGER(A-Z)
COMMON LINE(20,4),NODE(20,4),STACK(1000)
COMMON LLN,NLN,S,LA,FLN,RA,RI
COMMON /PRIPLO/ AMODES(200),PFLD(50,50)
REAL AMODES
IF (IFLG.EQ.0) GO TO 640
C CALL EXITG(AMODES)
RETURN
640 IX=AMODES(3)
IY=AMODES(4)
WRITE(6,643)
643 FORMAT(///)
DO 641 I=1,IY
641 WRITE(6,642) (PFLD(IA,I),IA=1,IX)
642 FORMAT(1H ,50A1)
WRITE(6,643)
RETURN
END